perm filename ALGOL.SAI[OK,TES] blob
sn#124332 filedate 1974-10-02 generic text, type T, neo UTF8
00100 IFC NOT DECLARATION(PUBLIC) THENC
00200 ENTRY ALGOL ;
00300
00400 BEGIN "ALGOL"
00500 DEFINE COMPILEFILE = "ALGOL" ;
00600 REQUIRE "SHARE" SOURCE!FILE ;
00700 ENDC
00800
00900 COMMENT
01000
01100 The ALGOL (SAIL) subset of PUB -- statements, conditionals, and
01200 expressions.
01300
01400 The statement parser is recursive descent. Its top-level production
01500 is MANUSCRIPT. A manuscript is a sequence of CHUNKs, including
01600 ASSIGNMENTs, LABELDEFinitions, COMMANDs, PROCedureSTATEMENTs, and
01700 TEXTLINEs.
01800
01900 The expression parser is iterative descent. Its top-level production
02000 is E. An E is a conditional expression, an assignment expression, or
02100 a simple expression.
02200
02300 ;
02400
02500 PROCEDURES
00100 PUBLIC SIMPLE PROCEDURE ALGOL! ;$"#
00200 BEGIN "ALGOL!"
00300 LIT!ENTITY ← LIT!TRAIL ← NULL ;
00400 EMPTYTHIS ; EMPTYTHAT ;
00500 END "ALGOL!" ;
00100 PUBLIC RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;$"#
00200 BEGIN
00300 IF PAGEMARKS > PAGEWAS THEN
00400 BEGIN comment, might be AT PAGEMARK response ;
00500 FOR PAGEWAS ← PAGEWAS + 1 THRU PAGEMARKS DO IF SIGNALD[FF] THEN RESPOND(SIGNALD[FF]) ;
00600 PAGEWAS ← PAGEMARKS ;
00700 END ;
00800 RETURN(THISISID AND (ASSIGNMENT OR LABELDEF OR COMMAND OR PROCSTATEMENT)
00900 OR TEXTLINE OR EMPTYCHUNK OR NONSENSE(VALID)) ;
01000 TES ADDED PROCSTATEMENT 8/20/74 ;
01100 END "CHUNK" ;
00100 PUBLIC RECURSIVE PROCEDURE DCONDITIONAL ;$"#
00200 BEGIN
00300 BOOLEAN WASON ;
00400 WASON ← ON ; PASS ; ON ← TRUESTR(E(NULL,"THEN")) ∧ WASON ;
00500 IF ITS(THEN) THEN PASS ELSE WARN("=","Missed THEN in conditional statement") ;
00600 IF STATEMENT THEN BEGIN ON←TRUE; RETURN END; TES 8/14/74 DONE FROM REPEAT ;
00700 IF ITS(ELSE) THEN BEGIN ON←WASON∧¬ON; PASS ; IF STATEMENT THEN BEGIN ON←TRUE; RETURN END END ;
00800 ON ← WASON ;
00900 END "DCONDITIONAL" ;
00100 PUBLIC RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;$"#
00200 COMMENT Scan a SAIL-Like <Expression>. First check trivial case. ;
00300 IF ITS(IF) THEN
00400 BEGIN "CONDITIONAL EXPRESSION"
00500 STRING BOOLX, THENX, ELSEX ; BOOLEAN WASON ;
00600 WASON ← ON ; PASS ;
00700 BOOLX ← E(NULL, "THEN") ; ON ← WASON ∧ TRUESTR(BOOLX) ;
00800 IF ITS(THEN) THEN PASS ELSE WARN("=","Missed THEN in conditional expression "&THISWD) ;
00900 THENX ← E(NULL, "ELSE") ;
01000 IF ITS(ELSE) THEN
01100 BEGIN
01200 ON ← WASON ∧ FALSTR(BOOLX) ; PASS ;
01300 ELSEX ← E(NULL, STOPWORD) ;
01400 END
01500 ELSE ELSEX ← NULL ;
01600 ON ← WASON ;
01700 RETURN(IF TRUESTR(BOOLX) THEN THENX ELSE ELSEX) ;
01800 END "CONDITIONAL EXPRESSION"
01900 ELSE IF THISTYPE = -TERQ ∨ THISTYPE = CMDTYPE ∨ ITSV(STOPWORD) THEN
02000 RETURN(DEFAULT) comment omitted expression ;
02100 ELSE IF THISTYPE ≥ -1 ∧ (THATTYPE = -TERQ ∨ THATTYPE=CMDTYPE ∨ NEXTSV(STOPWORD)) THEN
02200 RETURN(SPASS(<IF THISISCON THEN THISWD[2 TO ∞] ELSE VEVAL>))
02300 ELSE IF THISISID ∧ NEXTSCH(←) THEN comment, Assignment Expression ;
02400 RETURN(VASSIGN(SYMB, THISTYPE, IX, E(IPASS(PASS), STOPWORD)))
02500 ELSE
02600 BEGIN "SIMPLE EXPRESSION"
02700 STRING ANY, comment, result of A∨B∨...: has value of first TRUE operand;
02800 ALL, comment, result of A∧B∧...: has value of first FALSE operand;
02900 COMPARE, comment, result of A<B≤...: TRUE if all relations are TRUE;
03000 LEFT, comment, preceding right comparator, saved for another comparison;
03100 BOUNDARY, comment, result of A MAX B MIN... ;
03200 PRODUCT, comment, result of * / MOD & ;
03300 PRIMARY ; comment, <const>|<var>|( <expr> )|<unary><primary>|<primary><substr spec> ;
03400 INTEGER OROP, comment, =0 signals ∨ waiting for right operand ;
03500 ANDOP, NOTOP, comment, =0 signals ∧ or ¬ operator waiting ;
03600 RELOP, ODDOP, BOUNDOP, ADDOP, MULOP, comment, ≥0 signals operator waiting ;
03700 UNARYOP, comment, ≥0 signals unary operators waiting ;
03800 U, comment, last of a series of unary operators ;
03900 SS1, comment, starting byte number in substring spec ;
04000 SAVEINF, comment, saved outside value of ∞ ;
04100 SYMPTR, comment, symbol table number of identifier ;
04200 IDTYPE, comment, type field in its NUMBER entry ;
04300 ICOMPARE, ILEFT, IBOUNDARY, ISUM, IPRODUCT, IPRIMARY ; comment, CVD(corresponding string);
04400 BOOLEAN WASONA, WASONO ; comment value of ON before a series of conjuncts or disjuncts ;
04500 DEFINE TRYFAMILY(FAM) = [IF THISTYPE=-FAM THEN IPASS(IX)];
04600 COMMENT Multiple Unary operators ( + , - , ABS , LENGTH , XLENGTH , and ↑ ) are combined
04700 into a single operator by inventing new operators such as
04800 "-ABS" and "ABS LENGTH" ;
04900 DEFINE P = [0], comment, +X ; M = [1], comment, -X ; A = [2], comment, ABS X ;
05000 MA = [3], comment, -ABS X ; C = [4], comment, ↑X ;
05100 L = [5], comment, LENGTH(X) ; ML = [6], comment -LENGTH(X) ;
05200 AL = [7], comment, ABS LENGTH(X) ; MAL = [8], comment, -ABS LENGTH(X) ;
05300 Z = [9], comment, XLENGTH(X) ; MZ = [10], comment -XLENGTH(X) ;
05400 AZ = [11], comment, ABS XLENGTH(X) ; MAZ = [12]; comment, -ABS XLENGTH(X) ; TES 8/14/74 ;
05500 PRELOAD!WITH comment RIGHT OPERATOR
05600 ---------------------------------
05700 LEFT OPERATOR + - ABS ↑ LENGTH XLENGTH
05800 ------------- --- --- --- --- -------- ---------
05900 none; P, M, A, C, L, Z,
06000 comment P ; P, M, A, P, L, Z,
06100 comment M ; M, P, MA, M, ML, MZ,
06200 comment A ; A, A, A, A, AL, AZ,
06300 comment MA ; MA, MA, MA, MA, MAL, MAZ,
06400 comment C ; P, M, A, C, L, Z ;
06500 OWN INTEGER ARRAY COMBINE[-1:4,0:5] ;
06600 COMMENT This is a top-down expression parser, but iteration is used
06700 instead of recursion for rapidity ;
06800
06900 OROP ← ANDOP ← NOTOP ← RELOP ← BOUNDOP ← ADDOP ← MULOP ← -1 ;
07000 WASONO ← ON ;
07100 DO BEGIN "DISJUNCTS" COMMENT Operands of ∨ ;
07200 WASONA ← ON ;
07300 DO BEGIN "CONJUNCTS" COMMENT Operands of ∧ ;
07400 WHILE THISTYPE = -NOTQ DO BEGIN NOTOP ← -1 - NOTOP ; PASS END ;
07500 ICOMPARE ← TRUE ;
07600 DO BEGIN "COMPARATORS" COMMENT Operands of < = etc. ;
07700 ODDOP ← TRYFAMILY(ODDQ) ELSE -1 ;
07800 DO BEGIN "BOUNDS" COMMENT Operands of MAX and MIN ;
07900 DO BEGIN "TERMS" COMMENT Operands of + - ≡ ⊗ ;
08000 DO BEGIN "FACTORS" COMMENT Operands of * / MOD & ;
08100 UNARYOP ← -1 ; COMMENT check for Unary Operators ;
08200 WHILE UNARYOP≤3 COMMENT no, P, M, A, or MA left operator ;
08300 AND 0 ≤ (U ← TRYFAMILY(ADDQ) ELSE -1) COMMENT some right operator ;
08400 DO UNARYOP ← COMBINE[UNARYOP, U] ;
08500 comment PRIMARY ;
08600 IF THISISCON THEN BEGIN PRIMARY ← THISWD[2 TO ∞] ; PASS END
08700 ELSE IF THISISID THEN
08800 IF ITSV(STOPWORD) THEN
08900 BEGIN
09000 PRIMARY ← DEFAULT ;
09100 WARN("=","Ill-Formed Expression" & THISWD) ;
09200 END
09300 ELSE IF PROCSTATEMENT THEN PRIMARY ← PROCVALUE
09400 ELSE IF NEXTSCH(<(>) THEN
09500 BEGIN "FUNCALL" TES 8/19/74 ;
09600 IF ITS(DECLARATION) THEN
09700 BEGIN
09800 PASS ; PASS ;
09900 PRIMARY ← CVS(THISTYPE) ; PASS ;
10000 END
10100 ELSE IF ITS(OCTAL) THEN
10200 BEGIN
10300 STRING T ;
10400 PRIMARY ← NULL ; PASS ; PASS ; T ← E(NULL,NULL) ;
10500 WHILE T DO PRIMARY ← PRIMARY & "'" & CVOS(LOP(T)) ;
10600 END
10700 ELSE IF ITS(BEWARE) THEN
10800 BEGIN TES 8/21/74 INVERSE OCTAL ;
10900 STRING T ; INTEGER BRC ;
11000 PRIMARY ← NULL ; PASS ; PASS ; T ← E(NULL,NULL) ;
11100 SETBREAK(LOCAL!TABLE,"'",NULL,"IS") ;
11200 DO BEGIN
11300 SCAN(T, LOCAL!TABLE, BRC) ;
11400 IF BRC THEN PRIMARY ← PRIMARY & CVO(T) ;
11500 END UNTIL NOT BRC ;
11600 END
11700 ELSE IF ITS(SCAN) THEN
11800 BEGIN "SCANCALL"
11900 BOOLEAN ISBRC ;
12000 STRING STR, STOPPERS, IGNORES, OPTIONS ;
12100 INTEGER SYMWAS, IXWAS, TYPEWAS, BRC ;
12200 STOPPERS←IGNORES←OPTIONS←NULL ;
12300 ISBRC ← FALSE ; PASS ; PASS ;
12400 IF THISISID AND NEXTSCH(<,>) THEN
12500 BEGIN COMMENT VARIABLE TO LOP ;
12600 SYMWAS←SYMBOL; IXWAS←IX; TYPEWAS←THISTYPE;
12700 STR ← VEVAL ; PASS ;
12800 END
12900 ELSE BEGIN COMMENT EXPRESSION ;
13000 IXWAS ← -1 ;
13100 STR ← E(NULL, NULL) ;
13200 END ;
13300 IF ITSCH(<,>) THEN
13400 BEGIN COMMENT STOPPERS ;
13500 PASS ; STOPPERS←E(NULL, NULL) ;
13600 IF ITSCH(<,>) THEN
13700 BEGIN COMMENT IGNORES ;
13800 PASS ; IGNORES ← E(NULL,NULL) ;
13900 IF ITSCH(<,>) THEN
14000 BEGIN COMMENT OPTIONS ;
14100 PASS ; OPTIONS ← E(NULL,NULL) ;
14200 IF ITSCH(<,>) THEN
14300 BEGIN COMMENT BRC VARIABLE ;
14400 PASS ;
14500 IF THISISID AND NEXTSCH(<)>) THEN
14600 ISBRC←TRUE
14700 ELSE WARN(NULL, "SCAN's BRC must be variable name") ;
14800 END ;
14900 END ;
15000 END ;
15100 END ;
15200 SETBREAK(LOCAL!TABLE, STOPPERS, IGNORES,
15300 IF FULSTR(OPTIONS) THEN OPTIONS ELSE "IR") ;
15400 PRIMARY ← SCAN(STR, LOCAL!TABLE, BRC) ;
15450 BREAKSET(LOCAL!TABLE, NULL, "O") ; TES 10/1/74 ;
15500 IF ISBRC THEN
15600 BEGIN
15700 VASSIGN(SYMBOL, THISTYPE, IX, IF BRC=0 THEN NULL ELSE BRC) ;
15800 PASS ;
15900 END ;
16000 IF IXWAS NEQ -1 THEN VASSIGN(SYMWAS, TYPEWAS, IXWAS, STR) ;
16100 END "SCANCALL"
16200 ELSE BEGIN
16300 WARN(NULL,"Unknown Function " & THISWD) ;
16400 PASS ; PASS ; PRIMARY ← DEFAULT ;
16500 WHILE NOT ITSCH(<)>) DO
16600 IF ITSCH(<,>) THEN PASS
16700 ELSE E(NULL,NULL) ;
16800 END ;
16900 IF ITSCH(<)>) THEN PASS
17000 ELSE WARN(NULL, <"Missing ) after function call">) ;
17100 END "FUNCALL"
17200 ELSE BEGIN PRIMARY ← VEVAL ; PASS END
17300 ELSE IF ITSCH(<(>) THEN
17400 BEGIN "( <EXPR> )"
17500 PASS ; PRIMARY ← E(DEFAULT, 0) ;
17600 IF ITSCH(<)>) THEN PASS ELSE WARN("=",<"Missed )">) ;
17700 END "( <EXPR> )"
17800 ELSE BEGIN WARN("=","Ill-Formed expression" & THISWD) ; PRIMARY ← DEFAULT END ;
17900 WHILE THISTYPE=-BROKQ DO COMMENT Substring Specifications ;
18000 BEGIN "SUBSPEC"
18100 PASS ; SAVEINF ← INF ; INF ← LENGTH(PRIMARY) ;
18200 SS1 ← CVD(E("1", IF NEXTS(TO) THEN "TO" ELSE "FOR")) ;
18300 IF ITS(TO) THEN BEGIN PASS ; PRIMARY←PRIMARY[SS1 TO CVD(E("0",0))] END
18400 ELSE IF ITS(FOR) THEN BEGIN PASS ; PRIMARY←PRIMARY[SS1 FOR CVD(E("1",0))] END
18500 ELSE PRIMARY ← PRIMARY[SS1 FOR 1] ;
18600 SAIL!SKIP! ← !SKIP! ;
18700 IF ITSCH(<]>) THEN PASS ELSE WARN("=",<"Missed ] in substring spec " & THISWD>) ;
18800 INF ← SAVEINF ;
18900 END "SUBSPEC" ;
19000 IF UNARYOP≤3 THEN COMMENT both int & str versions maintained when needed ;
19100 IPRIMARY ← IF PRIMARY="'" THEN CVO(PRIMARY[2 TO ∞]) TES 8/19/74 ;
19200 ELSE CVD(PRIMARY) ;
19300 IF UNARYOP ≥ 0 THEN IF UNARYOP=C THEN IPRIMARY←CVD(PRIMARY←CAPITALIZE(PRIMARY))
19400 ELSE PRIMARY ← CVS(IPRIMARY ← CASE UNARYOP OF (IPRIMARY, -IPRIMARY,
19500 ABS IPRIMARY, -ABS IPRIMARY, 0, LENGTH(PRIMARY), -LENGTH(PRIMARY),
19600 ABS LENGTH(PRIMARY), -ABS LENGTH(PRIMARY),
19700 XLENGTH(PRIMARY), -XLENGTH(PRIMARY),
19800 ABS XLENGTH(PRIMARY), -ABS XLENGTH(PRIMARY) ) ) ; TES 8/14/74;
19900 IF MULOP<0 THEN BEGIN PRODUCT ← PRIMARY ; IPRODUCT ← IPRIMARY END
20000 ELSE IF MULOP = 3 THEN IPRODUCT ← CVD(PRODUCT ← PRODUCT & PRIMARY)
20100 ELSE PRODUCT ← CVS(IPRODUCT ← IF IPRIMARY=0 ∨ ¬ON THEN 0 ELSE CASE MULOP OF
20200 (IPRODUCT*IPRIMARY, IPRODUCT DIV IPRIMARY, IPRODUCT MOD IPRIMARY) ) ;
20300 MULOP ← TRYFAMILY(MULQ) ELSE -1 ;
20400 END "FACTORS" UNTIL MULOP < 0 ;
20500
20600 ISUM ← CASE ADDOP+2 OF (IPRODUCT, IPRODUCT, ISUM + IPRODUCT,
20700 ISUM - IPRODUCT, ISUM ≡ IPRODUCT, ISUM ⊗ IPRODUCT) ;
20800 ADDOP ← TRYFAMILY(ADDQ) ELSE IF ADDOP<0 THEN -1 ELSE -2 ;
20900 END "TERMS" UNTIL ADDOP < 0 ;
21000
21100 IBOUNDARY ← CASE BOUNDOP+2 OF (ISUM, ISUM, IBOUNDARY MAX ISUM, IBOUNDARY MIN ISUM) ;
21200 BOUNDOP ← TRYFAMILY(BOUNDQ) ELSE IF ADDOP=-1 ∧ BOUNDOP<0 THEN -1 ELSE -2 ;
21300 END "BOUNDS" UNTIL BOUNDOP < 0 ;
21400 BOUNDARY ← IF BOUNDOP = -1 THEN PRODUCT COMMENT, hasn't changed since then; ELSE CVS(IBOUNDARY) ;
21500 IF ODDOP≥0 THEN BOUNDARY←CVS(IBOUNDARY←(IBOUNDARY MOD 2)=ODDOP);
21600 IF ICOMPARE THEN CASE RELOP+2 OF BEGIN comment SAIL Bug precludes case expression with relationals;
21700 BEGIN END ; BEGIN END ; ICOMPARE←ILEFT<IBOUNDARY; ICOMPARE←ILEFT>IBOUNDARY; ICOMPARE ←
21800 EQU(LEFT,BOUNDARY); ICOMPARE←ILEFT≤IBOUNDARY; ICOMPARE←ILEFT≥IBOUNDARY;
21900 ICOMPARE←¬EQU(LEFT,BOUNDARY) END ;
22000 RELOP ← TRYFAMILY(RELQ) ELSE IF RELOP < 0 THEN -1 ELSE -2 ;
22100 LEFT ← BOUNDARY ; ILEFT ← IBOUNDARY ;
22200 END "COMPARATORS" UNTIL RELOP < 0 ;
22300 COMPARE ← IF RELOP=-1 THEN BOUNDARY ELSE CVS(ICOMPARE) ;
22400 IF NOTOP = 0 THEN COMPARE ← IF TRUESTR(COMPARE) THEN "0" ELSE "-1" ;
22500 NOTOP ← -1 ;
22600 IF ANDOP < 0 OR TRUESTR(ALL) THEN IF FALSTR(ALL ← COMPARE) THEN ON ← FALSE ;
22700 ANDOP ← TRYFAMILY(ANDQ) ELSE -1 ; ALL ← ALL ; comment SAIL bug -- force it to store;
22800 END "CONJUNCTS" UNTIL ANDOP < 0 ;
22900 ON ← WASONA ;
23000 IF OROP < 0 OR FALSTR(ANY) THEN IF TRUESTR(ANY ← ALL) THEN ON ← FALSE ;
23100 OROP ← TRYFAMILY(ORQ) ELSE -1 ; ANY ← ANY ; comment SAIL bug -- force it to store ;
23200 END "DISJUNCTS" UNTIL OROP < 0 ;
23300 ON ← WASONO ;
23400 RETURN(DUMMYSTR ← ANY) ; comment, DUMMYSTR due to SAIL RECURSIVE STRING PROCEDURE bug (see DCS);
23500 END "SIMPLE EXPRESSION" ;
00100 PRIVATE BOOLEAN SIMPLE PROCEDURE EMPTYCHUNK ;$"#
00200 RETURN(IF ITSCH(;) THEN IPASS(TRUE) ELSE FALSE) ;
00100 PUBLIC SIMPLE PROCEDURE MANUSCRIPT ;$"#
00200 BEGIN
00300 BOOLEAN VALID ;
00400 PASS ; COMMENT 9/9/74 TES ;
00500 VALID ← TRUE ;
00600 DO VALID ← CHUNK(VALID) UNTIL LAST < 1 ;
00700 IF ¬NEXTS(7!MANUSCRIPT) THEN WARN("=","Brackets don't pair up!!!!!!!!!") ;
00800 FINPORTION ; IF BLNMS=0 THEN ENDBEGIN ELSE IF BLNMS>0 THEN
00900 WARN("=",CVS(BLNMS) & " Extra BEGINs and STARTs") ;
01000 END "MANUSCRIPT" ;
00100 PRIVATE BOOLEAN SIMPLE PROCEDURE NONSENSE(BOOLEAN VALID) ;$"#
00200 BEGIN
00300 IF VALID THEN WARN("=","Can't make sense out of: "&SOMEINPUT) ;
00400 PASS ; RETURN(FALSE) ;
00500 END "NONSENSE" ;
00100 PUBLIC RECURSIVE BOOLEAN PROCEDURE STATEMENT ;$"#
00200 BEGIN "STATEMENT"
00300 INTEGER LVL, RLVL ; BOOLEAN VALID ;
00400 LVL ← BLNMS ; RLVL ← DEEPREPEATS ; TES 8/14/74 ;
00500 DO VALID ← CHUNK(VALID) UNTIL BLNMS≤LVL ;
00600 RETURN(RLVL > DEEPREPEATS) ; TES 8/14/74 ;
00700 END "STATEMENT" ;
00100 FINISHED
00200
00300 END "ALGOL"